COMMENT ⊗   VALID 00008 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	entry begin comment The output module of TEX.
C00004 00003	initialization: initout,declareofil
C00009 00004	Output codes for Press.
C00021 00005	General description of the shipout procedure.
C00028 00006	The recursive traversal procedures: vlistout,hlistout
C00038 00007	internal procedure shipout(integer p) # the main output procedure,produces one page
C00041 00008	internal procedure closeout # just before TEX stops, do this
C00045 ENDMK
C⊗;
entry; begin comment The output module of TEX.

Modified by D. Wyatt and Leo Guibas to produce Press files for PARC.

(It is wise to read the box data structure definitions in TEXSEM
before going very deeply into the following code.)

Each TEXOUT module is supposed to include the following procedures
invoked by the main program:

	initout			gets the output module started initially
	declareofil(string s) called when the output file name is known
	shipout(integer p)	called for each nonempty page to be output
	closeout		finishes the output
;

require "TEXHDR.SAI" source_file;
require "
	Note: This output module prepares PRESS files only. " message;
comment initialization: initout,declareofil;

internal string ofilext # filename extension for output;
internal string deviceext # extension to use in font information files;
internal string ofilname # output file name, set by first \input;
internal string libraryarea # default system area for fonts;
integer ochan, jfn # output channel number and tenex jfn;
boolean no_output_yet # no pages shipped out yet;
integer recnum, outcount # current record and byte numbers;

define maxparts=400;
saf integer array partdir[0:2*maxparts];
integer pdptr, nparts # byte pointer into partdir, number of parts;

define rfudge=⊂1.1⊃ # resolution fudge factor;
define micasPerInch=⊂2540⊃;
define pointsPerInch=⊂72.27⊃;
define conv=⊂(rfudge*micasPerInch/pointsPerInch)⊃ # assumed number of micas per point;
define roundup(x)=⊂conv*(x)+.999999⊃ # integer←roundup(x) gives ceiling(x);
define pageheight=11*micasPerInch, pagewidth=8.5*micasPerInch;

IFPARC
comment Warning: these definitions shared among TEXPRS and TEXHDR!!;
external boolean color;
external integer curbrightness,curhue,cursaturation;
define brightness=0, hue=1, saturation=2;
ENDPARC

comment Procedures for 8-bit-byte file I/O;
define byteSizeShift=30 # shift for byte-size field in arg to openf;
define readAccess='200000, writeAccess='100000, appendAccess='20000;

comment the following two procedures do 8-bit byte output to a file
that has been appropriately opened for 8-bit transfers. jfn is the
full tenex jfn for the file [jfn ← cvjfn(chan)];

simple procedure Bout(integer byte);
	begin comment output an 8-bit byte;
	define bout=⊂jsys '51⊃;
		start_code
		move 1,jfn # destination;
		move 2,byte # the byte;
		bout;
		end;
	outcount←outcount+1;
	end;

simple procedure Wout(integer word);
	begin
	Bout(word lsh -8); Bout(word);
	end;

simple procedure Sout(integer ptr, bytecount);
	begin comment output a string of 8-bit bytes;
	if not(bytecount>0) then return # (-bytecount) must be negative!;
	define sout=⊂jsys '53⊃;
		start_code
		move 1,jfn # destination;
		move 2,ptr # string pointer;
		movn 3,bytecount # negative byte count;
		sout;
		end;
	outcount←outcount+bytecount;
	end;

simple integer procedure Bptr(reference integer base; integer byte);
	begin
	integer loc, b, p, ptr;
	define s=8;
	loc←location(base)+(byte div 4);
	b←byte mod 4;
	p←36-b*s;
	ptr←(((p lsh 6)+s) lsh 24)+loc;
	return(ptr);
	end;

simple integer procedure PadRecord(integer padval);
	begin
	integer padlength, i;
	padlength←-(outcount mod 512);
	if padlength<0 then padlength←padlength+512;
	for i←1 thru padlength do Bout(padval);
	return(padlength);
	end;

simple procedure BCPLout(string s; integer maxbytes);
	begin
	integer len, i;
	len←(maxbytes-1) min length(s);
	Bout(len);
	for i←1 thru maxbytes-1 do
		if i<=len then Bout(s[i to i]) else Bout(0);
	end;

comment Output codes for Press.


comment Press Entity list commands;
define
	ELShowCharactersShort = '0,
	ELSetSpaceXShort = '140,
	ELFont = '160,
	ELSetX = '356,
	ELSetY = '357,
	ELShowCharacters = '360,
	ELSetSpaceX = '364,
	ELResetSpace = '366,
	ELShowRectangle = '376,
	ELNop = '377,
	ELSetBrightness = '370,
	ELSetHue = '371,
	ELSetSaturation = '372;

short integer en # current entity (0,1,2, or 3);
define d0max=8000, e0max=10000, d1max=8000, e1max=10000;
define d2max=8000, e2max=10000, d3max=8000, e3max=10000;
define d0len=d0max div 4, d1len=d1max div 4;
define d2len=d2max div 4, d3len=d3max div 4;
define e0len=e0max div 4, e1len=e1max div 4;
define e2len=e2max div 4, e3len=e3max div 4;
saf integer array dl0[0:d0len];
saf integer array el0[0:e0len];
saf integer array dl1[0:d1len];
saf integer array el1[0:e1len];
saf integer array dl2[0:d2len];
saf integer array el2[0:e2len];
saf integer array dl3[0:d3len];
saf integer array el3[0:e3len];
saf integer array dlp[0:3] # data list pointers;
saf integer array elp[0:3] # entity list pointers;
preload_with d0max,d1max,d2max,d3max;
saf integer array dmax[0:3] # max permissible data list count (bytes);
preload_with e0max,e1max,e2max,e3max;
saf integer array emax[0:3] # max permissible entity list count (bytes);
DEBUGONLY integer array dlmaxused[0:3] # max attained data list count (bytes);
DEBUGONLY integer array elmaxused[0:3] # max attained entity list count (bytes);
saf integer array dct[0:3] # current data list count (bytes);
saf integer array ect[0:3] # current entity list count (bytes);
saf integer array pch[0:3] # number of pending chars in data list;
saf integer array cx[0:3] # current x position;
saf integer array cy[0:3] # current y position;
saf integer array cf[0:3] # current font;
define fontset(f)=⊂(f lsh -4)⊃ # 0-15 are set 0, 16-31 are set 1, etc.;
define fontnum(f)=⊂(f land '17)⊃;

comment Procedures for dealing with DL and EL;

simple procedure StartPage;
	begin
	integer i;
	comment initialize byte pointers into DL and EL;
	dlp[0]←point(8, dl0[0], -1);
	dlp[1]←point(8, dl1[0], -1);
	dlp[2]←point(8, dl2[0], -1);
	dlp[3]←point(8, dl3[0], -1);
	elp[0]←point(8, el0[0], -1);
	elp[1]←point(8, el1[0], -1);
	elp[2]←point(8, el2[0], -1);
	elp[3]←point(8, el3[0], -1);
	for i←0 step 1 until 3 do
		begin dct[i]←0; ect[i]←0; pch[i]←0; cx[i]←0; cy[i]←0; cf[i]←0 end;
	en←0;
IFPARC	if color then
		begin
		if curbrightness ≠ 0 then SetBrightness(curbrightness);
		if curhue ≠ 0 then SetHue(curhue);
		if cursaturation ≠ 0 then SetSaturation(cursaturation);
		end; ENDPARC
	end;

simple procedure ELByte (integer b);
	begin
	if ect[en]≥emax[en] then overflow(emax[en]);
	idpb(b, elp[en]);
	ect[en]←ect[en]+1;
	end;

simple procedure ELWord (integer w);
	begin ELByte(w lsh -8); ELByte(w) end;

simple procedure ELDWord (integer d);
	begin ELWord(d lsh -16); ELWord(d) end;

simple procedure DLByte (integer b);
	begin
	if dct[en]≥dmax[en] then overflow(dmax[en]);
	idpb(b, dlp[en]);
	dct[en]←dct[en]+1;
	end;

simple procedure DLWord (integer w);
	begin DLByte(w lsh -8); DLByte(w) end;

simple procedure AddPart(integer parttype, beginrec, nrecs, pad(0));
	begin
	if nparts≥maxparts then overflow(nparts);
	idpb(parttype, pdptr);
	idpb(beginrec, pdptr);
	idpb(nrecs, pdptr);
	idpb(pad, pdptr);
	nparts←nparts+1;
	end;

simple procedure PutChar(integer c);
	begin
	DLByte(c); pch[en]←pch[en]+1;
	end;

simple procedure Flush;
	begin
	short integer n;
	n←pch[en];
	if n>0 then
		begin
		if n≤32 then ELByte(ELShowCharactersShort+n-1)
		else begin ELByte(ELShowCharacters); ELByte(n); end;
		pch[en]←0;
		end;
	end;

simple procedure FlushAll;
	begin integer sen,i;
	sen←en;
	for i←0 thru 3 do
		begin
		en←i;
		Flush;
		end;
	en←sen;
	end;

simple procedure SetX(integer x);
	begin
	Flush; ELByte(ELSetX); ELWord(cx[en]←x);
	end;

simple procedure SetY(integer y);
	begin
	y←pageheight-y # invert y direction;
	comment note the assumption that ShowCharacters doesn't change y;
	if y≠cy[en] then
		begin Flush; ELByte(ELSetY); ELWord(cy[en]←y); end;
	end;

IFPARC
internal simple procedure SetBrightness(integer b);
	begin integer sen, i;
	FlushAll;
	sen←en;
	for i←0 thru 3 do
		begin
		en←i;
		ELByte(ELSetBrightness);
		ELByte(b);
		end;
	en←sen;
	end;

internal simple procedure SetHue(integer h);
	begin integer sen, i;
	FlushAll;
	sen←en;
	for i←0 thru 3 do
		begin
		en←i;
		ELByte(ELSetHue);
		ELByte(h);
		end;
	en←sen;
	end;

internal simple procedure SetSaturation(integer s);
	begin integer sen, i;
	FlushAll;
	sen←en;
	for i←0 thru 3 do
		begin
		en←i;
		ELByte(ELSetSaturation);
		ELByte(s);
		end;
	en←sen;
	end;

internal simple procedure PutColor(integer clrcmd,clrval);
case clrcmd of begin
[hue] SetHue(clrval);
[saturation] SetSaturation(clrval);
[brightness] SetBrightness(clrval);
else comment do nothing;
  end;
ENDPARC

simple procedure PutRectangle(integer x0,y0,h,w);
	begin comment x0,y0 specify the upper left corner;
	en←3 # put all rectangles in entity 1;
	Flush;
	SetX(x0); SetY(y0+h);
	ELByte(ELShowRectangle); ELWord(w); ELWord(h);
	end;

simple procedure SetFont(integer f);
	begin
	integer t;
	comment switch entities if necessary;
	en←fontset(f) # 0-15 are in font set 0, 16-31 in set 1, etc.;
	t←fontnum(f) # font number in font set;
	if cf[en]≠t then begin Flush; ELByte(ELFont+(cf[en]←t)); end;
	end;

comment append a trailer to entity list n;
simple procedure ETrailer(integer n, beginbyte, bytelength);
	begin
	en←n;
	Flush # don't forget to flush out pending characters!;
	if ect[en]=0 then return # empty entity - leave it empty;
	if (ect[en] mod 2) ≠ 0 then ELByte(ELNop) # pad to word boundary;
	ELByte(125) # type;
	ELByte(en) # font set;
	ELDWord(beginbyte) # beginning of DL region;
	ELDWord(bytelength) # length of DL region;
	ELWord(0); ELWord(0) # origin (Xe, Ye);
	ELWord(0); ELWord(0) # bottom left corner of bounding box;
	ELWord(pagewidth); ELWord(pageheight) # dimensions of bounding box;
	ELWord(ect[en] div 2+1) # entity length in WORDS (including this number);
	comment Assertion: the entity now contains an even number of bytes;
	end;

define outchar(c)=⊂PutChar((c)land '177)⊃ # macro for output of a single character;
define outrule(x0,y0,h,w)=⊂PutRectangle(x0,y0,((h)max 0),((w)max 0)⊃;
define newfont(f)=⊂SetFont(f)⊃;
define setpos(x0,y0)=⊂SetY(y0); SetX(x0)⊃;


internal procedure initout # get TEXOUT started properly;
begin
ofilname←null;
ofilext←".PRESS";
deviceext←".TFP";
libraryarea←"<TEX>" # default directory for font info;
ochan←-1; no_output_yet←true;
end;

internal procedure declareofil(string s) # initializes the output on file s;
begin comment This procedure is called when the name of the output file is
first known. It opens the file and gets things started;
integer i;
ofilname←s;
ochan←gtjfn(ofilname,1);
openf(ochan, (8 lsh byteSizeShift)+writeAccess) # byte size 8, write;
jfn ← cvjfn(ochan);
recnum←0;
outcount←0;
pdptr←point(16, partdir[0], -1);
nparts←0;
DEBUGONLY for i←0 thru 1 do begin dlmaxused[i]←elmaxused[i]←0 end;
end;
comment General description of the shipout procedure.

The simplest imaginable shipout routine would essentially be a recursive
procedure that goes through the data structure of the given page and,
whenever coming to a character or rule node, it would cause that character or
rule to be output to the appropriate place depending on its context.
This routine would periodically issue commands to the output device,
saying "Put such-and-such a character (or rule) in such and such a place."

A simple routine of that sort won't work on the XGP, because the XGP server
needs to get its commands sorted in order of the top edges of the characters
and rules. Furthermore one should probably make use of the fact most of
TEX's output is simple text --  extra care can be taken to make the output
occur faster in simple cases.

Therefore this shipout procedure has been constructed by taking the
simple recursive scheme and augmenting it in two ways: On simple text,
most of the generality is omitted, and there is a sorting process that
takes place before actual output occurs to the XGP.

As we have seen, the XGP server gets its instructions in character mode,
so TEXOUT builds a file of 7-bit characters and control codes. Sequences
of 7-bit characters having the same y0-value (i.e., the same top edge
of the type) are generated and then sorted by y0.  A different sequence is
begun for every box and, within a box, every time a rule or sub-box appears,
or whenever a font change causes the value of y0 to change.

A further complication, of course, is that TEX computes everything as if it
had "infinite precision" while actual devices like the XGP have only finite
resolution. Rounding in this TEXOUT module is done by converting each
real-valued coordinate pair (x,y) into the integer-value discrete raster
position ([conv*x+.14159],[conv*y+.14159]). Here conv is the conversion factor
from points to XGP pixels, and .14159 is an arbitrary offset which makes it
unlikely that rounding discontinuities will occur at points with physical
significance.

The conversion factor conv used in this program is figured on the basis
that the Stanford XGP has 259.2 pixels per 72 points.  The XGP really has
200 pixels per inch, so TEX output is somewhat magnified. The reason for
doing this is that XGP output is intended to be used either for proofreading
(when larger type should enhance the readability) or for printing (when a
reduction factor of about 10/13 will improve the appearance of the
machine's rather low-resolution output). 

Instead of adding .14159 when rounding, this constant is actually absorbed
into the offsets which are routinely computed as the data structure is
being traversed -- all computation is done relative to some arbitrary
starting point, so the .14159/conv is simply included in this starting point.
;

comment Modifications for Press:
Since Press is intended to be a relatively device-independent representation,
positions are computed in micas (1 mica = 10 microns = 1/2540 inch) rather
than in pixels for some particular device. Fortunately, Press format does not
require objects to be sorted by position, so the press output routine can be
much closer to the "simplest imaginable shipout routine" described above.
Of course, there are complications...

The XGP's convention is that increasing y goes downward. The Press convention
is the opposite (increasing y upward). However, to avoid much error-prone
modification of the code, the y-downward convention is maintained, and y
is transformed only within the SetY procedure, assuming an 11-inch-high page.

What constitutes an "entity" in a page of TEX output is not clear. One view
would treat each TEX "box" as an entity, but this would entail an absurd amount
of overhead, since even single characters are packaged in individual boxes.
The extreme opposite view, adopted here, treats the entire page as one
very large entity. Actually, TWO entity lists (and corresponding data lists)
are maintained, since two font sets are needed to accommodate 32 fonts.
To direct characters and commands to the proper entity requires some care.
;
comment The recursive traversal procedures: vlistout,hlistout;

forward recursive procedure hlistout(integer p; real x,y) # see below;

recursive procedure vlistout(integer p; real x,y);
begin comment This procedure generates instruction strings to output the
vlist box pointed to by p, where the upper left corner of the box is to
have coordinates (x,y);
comment N.B.: y is the TOP of the box!;
integer q # runs through the vlist;
integer m # mem[q];
real g # the glueset parameter for this box;
short integer x0,y0,h,w # units rounded to micas;
comment rounding from real to short integers is faster than to general integers;

q←value(p); g←glueset(p); x0←conv*x;
while q do
	begin case field(type,m←mem[q]) of begin
	[charnode] begin integer c,f,w;
	c←field(info,m); f←c lsh -7; w←fontinfo[c] # get character and font;
	fontinfo[c]←w lor flag # mark character "used";
	y←y+charht(f,w); y0←conv*y # baseline;
	comment Now (x0,y0) is reference point (in micas) where c should go;
	newfont(f); setpos(x0,y0); outchar(c) # DO NEWFONT FIRST! (may change en);
	y←y+chardp(f,w); end;
	[gluenode] begin integer r; r←field(value,m) # pointer to glue spec;
	if g=0 then y←y+gluespace(r)
	else if g>0 then y←y+gluespace(r)+gluestretch(r)*g
	else y←y+gluespace(r)+glueshrink(r)*g; end;
	[kernnode] y←y+gluespace(q);
	[rulenode] begin comment horizontal rule;
	y0←conv*y; h←roundup(height(q)+depth(q));
	if width(q)≤-100000.0 then w←roundup(width(p)) else w←roundup(width(q));
	outrule(x0,y0,h,w); y←y+height(q)+depth(q) end;
	[whatsitnode] voutext(q,x,y) # for extensions to TEX;
	[vlistnode] begin vlistout(q,x+shiftamt(q),y);
	y←y+height(q)+depth(q); end;
	[hlistnode] begin hlistout(q,x+shiftamt(q),y←y+height(q));
	y←y+depth(q); end;
	[leadernode] begin integer b; real hh;
	b←field(value,m) # pointer to box used for vertical leaders;
	if type(b)≠rulenode or(height(b)<-100000.0 and depth(b)<-100000.0) then
		begin hh←height(b)+depth(b); if hh<0 then hh←0;
		end
	else hh←-1.0;
	if hh≠0 and type(link(q))=gluenode then
		begin integer r; real s;
		q←link(q); r←value(q) # pointer to glue spec;
		if g=0 then s←gluespace(r)
		else if g>0 then s←gluespace(r)+gluestretch(r)*g
		else s←gluespace(r)+glueshrink(r)*g;
		if hh>0 then
			begin integer q # quotient; real yy # y surrogate;
			q←y/hh-epsilon;
			yy←hh*(q+1) # the smallest suitable multiple of hh;
			while yy+hh≤y+s do
				begin if type(b)=vlistnode then vlistout(b,x,yy)
				else hlistout(b,x,yy+height(b));
				yy←yy+hh;
				end;
			end
		else	begin comment variable vertical rule;
			w←roundup(width(b));y0←conv*y;h←roundup(s);
			outrule(x0,y0,h,w);
			end;
		y←y+s;
		end;
	end;
	else end # ignore all other types of nodes;
	q←link(q);
	end;
end;

recursive procedure hlistout(integer p; real x,y);
begin comment This procedure generates instruction strings to output the
hlist box pointed to by p, where the reference point of the box is to
have coordinates (x,y);
comment N.B.: y is the BASELINE!;
integer q # runs through the hlist;
integer m # mem[q];
real g # the glueset parameter for this box;
short integer x0,y0,h,w # coordinates rounded to micas;
comment rounding from real to short integers is faster than to general integers;

q←value(p); g←glueset(p); y0←conv*y;
while q do
	begin case field(type,m←mem[q]) of begin
	[charnode] begin comment This is a first character of a possibly long
	list, a common case which is "optimized" to keep the number of
	instruction strings reasonably small;
	integer c,f,w,h;
	c←field(info,m) # the extended character code;
	f←c lsh -7 # the font code;
	w←fontinfo[c] # the font information fields;
	x0←conv*x # round to correct starting position;
	newfont(f) # must do this first - might switch entities!;
	setpos(x0,y0); outchar(c) # output c;
	x←x+charwd(f,w);
	while true do
		begin comment continue with same instruction stream
		as long as the nodes can be handled easily;
		integer f1 # font of new character;
		q←link(q);
		if q=0 then done;
		if field(type,m←mem[q])≠charnode then done;
		comment another charnode;
		c←field(info,m) # the extended character code;
		f1←c lsh -7 # the font code;
		comment must exit from loop if we switch font sets;
		if fontset(f1)≠fontset(f) then done;
		newfont(f←f1);
		w←fontinfo[c] # the font information fields;
		outchar(c) # output the character;
		x←x+charwd(f,w);
		end;
	continue end # resume "while q" loop;
	[gluenode] begin integer r; r←field(value,m) # pointer to glue spec;
	if g=0 then x←x+gluespace(r)
	else if g>0 then x←x+gluespace(r)+gluestretch(r)*g
	else x←x+gluespace(r)+glueshrink(r)*g; end;
	[kernnode] x←x+gluespace(q);
	[rulenode] begin comment vertical rule; integer y00;
	if height(q)≤-100000.0 then height(q)←height(p); h←roundup(height(q));
	y00←y0-h+1; comment this way of calculating y00 means that the rule will
		stop at the baseline if the depth is zero;
	if depth(q)≤-100000.0 then depth(q)←depth(p); h←roundup(height(q)+depth(q));
	x0←conv*x; x←x+width(q); w←roundup(width(q));
	outrule(x0,y00,h,w); end;
	[whatsitnode] houtext(q,x,y) # for extensions to TEX;
	[vlistnode] begin vlistout(q,x,y-height(q)+shiftamt(q)); x←x+width(q); end;
	[hlistnode] begin hlistout(q,x,y+shiftamt(q)); x←x+width(q); end;
	[leadernode] begin integer b; real ww;
	b←field(value,m) # pointer to box used for horizontal leaders;
	ww←width(b); if ww<0 and type(b)≠rulenode then ww←0;
	if ww≠0 and type(link(q))=gluenode then
		begin integer r; real s;
		q←link(q); r←value(q) # pointer to glue spec;
		if g=0 then s←gluespace(r)
		else if g>0 then s←gluespace(r)+gluestretch(r)*g
		else s←gluespace(r)+glueshrink(r)*g;
		if ww>0 then
			begin integer q # quotient; real xx # x surrogate;
			q←x/ww-epsilon;
			xx←ww*(q+1) # the smallest suitable multiple of ww;
			while xx+ww≤x+s do
				begin if type(b)=hlistnode then hlistout(b,xx,y)
				else vlistout(b,xx,y-height(b));
				xx←xx+ww;
				end;
			end
		else	begin comment variable horizontal rule; short integer y00;
			h←roundup(height(b));y00←y0-h+1;
			h←roundup(height(b)+depth(b));
			w←roundup(s);x0←conv*x;
			outrule(x0,y00,h,w);
			end;
		x←x+s;
		end;
	end;
	else end # ignore other node types;
	q←link(q);
	end;
end;
internal procedure shipout(integer p) # the main output procedure,produces one page;
begin comment Parameter p points to a vlist box that is to be output;
short integer y0prev,i,cutplace;
integer padbytes, nextrec;

if ochan<0 then declareofil("TEXOUT.PRESS") # make sure output file is open;

StartPage;
define inches(n)=⊂(micasPerInch*(n)+.14159)/conv⊃;
vlistout(p,inches(1),inches(1)) # prepare table of command strings;
comment the "inches(1)" here leaves an inch of margin for cases where the user
	has gone outside the box with negative glue;
no_output_yet←false;

comment all new code here for Press;
comment write data lists;
Sout(Bptr(dl0[0],0), dct[0]);
Sout(Bptr(dl1[0],0), dct[1]);
Sout(Bptr(dl2[0],0), dct[2]);
Sout(Bptr(dl3[0],0), dct[3]);
if (outcount mod 2) ≠ 0 then Bout(0) # pad to word boundary;

comment construct entity trailers;
ETrailer(0, 0, dct[0]);
ETrailer(1, dct[0], dct[1]);
ETrailer(2, dct[1]+dct[0], dct[2]);
ETrailer(3, dct[2]+dct[1]+dct[0], dct[3]);

Wout(0) # zero word to mark beginning of entity lists;
comment write entity lists;
Sout(Bptr(el0[0],0), ect[0]);
Sout(Bptr(el1[0],0), ect[1]);
Sout(Bptr(el2[0],0), ect[2]);
Sout(Bptr(el3[0],0), ect[3]);
padbytes←PadRecord(ELNop);

nextrec←outcount div 512;
AddPart(0, recnum, nextrec-recnum, padbytes div 2) # want WORDS of padding;
recnum←nextrec;

DEBUGONLY	for i←0 thru 3 do
DEBUGONLY		begin
DEBUGONLY		dlmaxused[i]←dlmaxused[i] max dct[i];
DEBUGONLY		elmaxused[i]←elmaxused[i] max ect[i];
DEBUGONLY		end;

end;
internal procedure closeout # just before TEX stops, do this;
begin integer n,f;
integer nextrec, logdir, dummy, pdlen, time, i;
string letters; integer lbt;

if no_output_yet then
	begin print(nextline,"No output file."); return;
	end;

comment initialize break table for parsing font names;
letters←"ABCDEFGHIJKLMNOPQRSTUVWXYZ";
setbreak(lbt←getbreak, letters, null, "KXR") # break on non-letter;

comment write the font directory part;
define entrylength=16 # in WORDS!!!;

for f←0 thru nfonts-1 do if fontname[f] then
	begin
	string name, fam;
	integer c, brchar;
	integer i, dev1, size, face, ptsize;
	name←fontname[f] # don't clobber fontname array;

	comment scan the font name up to the first nonletter to get family name;
	fam←scan(name, lbt, brchar);

	dev1←fmem[parbase[f]+device1] # face and size;
	face←dev1 lsh -18 # face code;
	size←dev1 land '777777 # size in micas;
	ptsize←pointsPerInch*size/micasPerInch+.5 # size in points, rounded;

	Wout(entrylength);
	Bout(f div 16) # font set;
	Bout(f land '17) # font number within set;
	Bout(0); Bout('177) # first and last characters;
	comment family name is a bcpl string, max 20 bytes;
	BCPLout(fam, 20);
	Bout(face) # face;
	Bout(0) # "source" character;
	Wout(ptsize) # should really be in micas, but PressEdit doesn't understand;
	Wout(0) # rotation;
	end;
Wout(0) # a zero word to mark the end of the font directory!;
PadRecord(0);
nextrec←outcount div 512;
AddPart(1, recnum, nextrec-recnum);
recnum←nextrec;

relbreak(lbt) # release break table;

comment write the part directory;
pdlen←8*nparts # 4 words (8 bytes) per part;
Sout(Bptr(partdir[0], 0), pdlen);
PadRecord(0);
nextrec←outcount div 512;

comment now, finally, the document directory;
Wout(27183) # general password;
Wout(nextrec+1) # total number of records in file (including this one);
Wout(nparts) # number of parts;
Wout(recnum) # start of part dir;
Wout(nextrec-recnum) # number of records in part dir;
Wout(-1) # back-pointer to obsolete document directory(?);
time←gtad # current date and time (tenex-style);
time←((time lsh -18)-15385)*(3600*24)+(time land '777777) # Alto-style time;
Wout(time lsh -16); Wout(time);
Wout(1); Wout(1) # first and last copy;
for i←10 thru '177 do Wout(-1);
BCPLout(ofilname, 2*26);
gjinf(logdir,dummy,dummy);
BCPLout(dirst(logdir), 2*16);
BCPLout(odtim(-1,'202301000000), 2*20);
PadRecord(0);

release(ochan);
end;
end